##############################################################################
# 
# High-level Tcl library for HTTP handling
#
# Copyright (c) 2013-14, Alexander Galanin <al@galanin.nnov.ru>
# All rights reserved.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
# 
# * Redistributions of source code must retain the above copyright notice,
#   this list of conditions and the following disclaimer.
# * Redistributions in binary form must reproduce the above copyright
#   notice, this list of conditions and the following disclaimer in the
#   documentation and/or other materials provided with the distribution.
# * Neither the name of Alexander Galanin nor the names of its contributors
#   may be used to endorse or promote products derived from this software
#   without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL Alexander Galanin BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
##############################################################################

package require Tcl 8.5
package require http
package require autoproxy
package require logger 0.9.3

package provide httplib 1.2

namespace eval httplib {

variable version 1.0
variable userAgent "httplib-tcl $version"

namespace export \
    init \
    get \
    post \
    clearReferer \
    cookie
namespace ensemble create

variable maxRetryCount 5
variable maxRedirectCount 5
variable refererSupport true

variable referer ""
variable timeout 5000
variable log

# Initialize http library, proxy and variables
# @param -useragent content of User-Agent header
# @param -maxretry maximum retries number on error
# @param -maxredirect meximum redirections
# @param -referer handle referers
proc init {args} {
    variable userAgent
    variable log

    set log [logger::init [namespace current]]

    set ua $userAgent
    set usage "usage: [namespace current]::init ?-useragent string? ?-maxretry number? ?-maxredirect number? ?-referer string? ?-timeout ms?"
    foreach {var value} $args {
        switch $var {
            -maxretry {
                variable maxRetryCount $value
            }
            -maxredirect {
                variable maxRedirectCount $value
            }
            -useragent {
                set ua $value
            }
            -referer {
                variable referer $value
            }
            -timeout {
                variable timeout $value
            }
            default {
                error "unknown switch `$var'. $usage"
            }
        }
    }

    autoproxy::init
    http::config \
        -useragent $ua
    if {![catch {package require tls}]} {
        http::register https 443 ::tls::socket
        ${log}::debug "registered https support"
    } else {
        ${log}::debug "package tls not present"
    }
}

# Perform HTTP GET request
# @param url URL to get
# @return reply content
proc get {url} {
    variable maxRetryCount
    variable maxRedirectCount
    variable log

    ${log}::info "getting $url"
    set res [httpExecute $maxRetryCount $maxRedirectCount $url]
    ${log}::debug "get from $url: $res"
    return $res
}

# Perform HTTP POST request
# @param url URL to get
# @param -data dictionary of POST form data
# @param -retry allow retrying on error
# @return reply content
proc post {url args} {
    variable maxRetryCount
    variable maxRedirectCount
    variable log

    set usage "usage: [namespace current]::post ?-retry bool? ?-data dict?"
    set retryCount $maxRetryCount
    set data {}
    foreach {var value} $args {
        switch $var {
            -retry {
                if {$value} {
                    set retryCount $maxRetryCount
                } else {
                    set retryCount 0
                }
            }
            -data {
                set data $value
            }
            default {
                error "unknown switch `$var'. $usage"
            }
        }
    }

    ${log}::info "posting '$args' to $url"
    set res [httpExecute $retryCount $maxRedirectCount $url \
        -query [http::formatQuery {*}$data] \
    ]
    ${log}::debug "data from $url: $res"
    return $res
}

# Check result of http::geturl call and determine what we needs to do.
# @param token result of http::geturl call
# @return action:
#   done <data> -- on OK
#   redirect <url> -- on redirect code
#   error <err> -- on errors
proc processHttpResult {token} {
    variable log

    switch [http::status $token] {
        ok {
            set meta [http::meta $token]
            # update cookies
            foreach {header value} $meta {
                if {[string tolower $header] eq "set-cookie"} {
                    cookie add $value
                }
            }
            switch -glob [http::ncode $token] {
                2** {
                    return [list done [http::data $token]]
                }
                3** {
                    # redirection
                    if {[dict exists $meta Location]} {
                        # redirect to a specified location
                        set url [dict get $meta Location]
                        ${log}::info "redirected to $url"
                        return [list redirect $url]
                    } else {
                        return [list error [http::code $token]]
                    }
                }
                default {
                    # temporary or persistent error
                    return [list error [http::code $token]]
                }
            }
        }
        eof {
            return {error "the server closes the socket without replying"}
        }
        error {
            return [list error [http::error $token]]
        }
        timeout {
            return {error "request timed out"}
        }
        default {
            error "unknown HTTP status `[http::status $token]'"
        }
    }
}

# Execute http::geturl with specified parameters.
# This procedure correctly handles redirects and tries to re-send HTTP
# query on error.
# @param numRetries maximum number of retries on error
# @param numRetries maximum number of redirects
# @param url URL request URL
# @param args arguments for http::geturl
# @return content of HTTP reply
proc httpExecute {numRetries numRedirects url args} {
    variable referer
    variable refererSupport
    variable timeout

    set headers {}
    while {$numRetries > 0 && $numRedirects > 0} {
        # handle referers
        if {$refererSupport && $referer ne ""} {
            dict set headers Referer $referer
        } else {
            dict set headers Referer $url
        }
        if {[set cookie [cookie value]] ne ""} {
            dict set headers Cookie $cookie
        }
        set referer $url
        # invoke http::geturl
        if {![catch {
            http::geturl $url {*}$args \
                -headers $headers \
                -timeout $timeout
        } res opts]} {
            # on correct finish
            lassign [processHttpResult $res] action value
            http::cleanup $res
            switch $action {
                done {
                    return $value
                }
                redirect {
                    set url $value
                    incr numRedirects -1
                    set err "too many redirects"
                }
                error {
                    set err $value
                    incr numRetries -1
                }
                default {
                    error "unknown action returned `$action'"
                }
            }
            dict set opts -errorinfo $err
            dict set opts -code 1
        } else {
            # on non-HTTP error
            set err $res
            break
        }
    }
    dict set opts -errorcode DOWNLOADER
    return -options $opts $err
}

# Clear referer variable
proc clearReferer {} {
    variable referer ""
}

namespace eval cookie {
namespace export \
    add \
    value \
    clear \
    import \
    export
namespace ensemble create

variable cookies {}

# Add value of HTTP responce header (Set-Cookie) to cookies dict
proc add {value} {
    variable cookies
    variable [namespace parent]::log

    if {[regexp {([^=]+)=(.*)} [lindex [split $value {;}] 0] _ key val]} {
        dict set cookies $key $val
        ${log}::info "set cookie $key = $val"
    } else {
        ${log}::warn "[namespace current]::add: malformed Set-Cookie header value: $value"
    }
}

# Get cookies as value for HTTP header (Cookie)
proc value {} {
    variable cookies

    set res {}
    dict for {k v} $cookies {
        lappend res $k=$v
    }
    join $res "; "
}

proc clear {} {
    variable cookies {}
}

# Import cookies from dict
proc import {values} {
    variable cookies $values
}

# Export cookies as dict
proc export {} {
    variable cookies
    return $cookies
}

}

}
